home *** CD-ROM | disk | FTP | other *** search
/ Best of Shareware / Best of PC Windows Shareware 1.0 - Wayzata Technology (7111) (1993).iso / mac / DOS / CAD_CAM / ADIPLT / ADI2COL.FOR < prev    next >
Text File  |  1990-10-24  |  10KB  |  336 lines
  1.                 program adi2col
  2.  
  3. !                ADI2COL file   (no extension in filename)
  4. !            input file extension must be .PLT
  5. !            output file extension will be .COL
  6. !            Jeff Casey    10/24/90
  7.  
  8. !            Translates output file from ACAD R10 generic ADI
  9. !                plotter driver to DEC LJ250 printer format.
  10. !            Printer runs at         X:  180 dots/in, 7.922in
  11. !                                    Y:  180 dots/in, 6.039in
  12. !            Configure ADI driver to X:  390 dots/in, 10.5in
  13. !                                    Y:  390 dots/in, 7.875in
  14. !                   (for consistency with ADI2TEK driver).
  15. !            Don't forget to map pen colors.
  16.  
  17. !        uses highest resolution (180 dpi) both axes.
  18. !        7 pen capability:  1-red, 2-yellow, 3-green, 4-cyan, 
  19. !            5-blue, 6-magenta, and 7-black.  
  20. !            pen numbers correspond to AutoCAD default.  
  21. !            pen number > 7 is same as 7 (black).
  22.  
  23.  
  24.     integer*1 i1
  25.     integer*2 ilen
  26.     integer*4 readx, ready
  27.     character*1 esc
  28.     character*15 f1, f2, f3, file
  29.     logical apen, blank
  30.     integer*2 unit(7), ppen(7)
  31.     integer*1 pixels [huge] (32368,6)    ! 32368 = 136 * 238 lines
  32.     integer*1 chrout, lastchr, pix(816)  ! 816 = one line (136) * 6rows
  33.     common /big/ pixels
  34.  
  35.     esc  = char(27)
  36.  
  37.     narg = nargs()                ! get input parameters
  38.     if (narg .ne. 2) call error
  39.  
  40.     call getarg (int2(1),file,ilen)        ! get filename
  41.     if (ilen .lt. 1) call error
  42.  
  43.     f1(1:ilen) = file(1:ilen)        ! open input file
  44.     f1(ilen+1:ilen+5) = '.plt'C
  45.     open (1,file=f1,status='old',iostat=ierr,form='binary')
  46.     if (ierr .ne. 0) call error
  47.  
  48.     iflen = ilen+4
  49.     f2 = f1                    ! open output file
  50.     f2(ilen+2:ilen+4) = 'col'
  51.  
  52.     write (*,' ('' Generic ADI Plotfile to DEC LJ250.''/
  53.      +        '' Translating file:  "'',a,''"  to file  "'',a,''".'')')
  54.      +                  f1(1:iflen), f2(1:iflen)
  55.  
  56.     open (2,file=f2,status='new',iostat=ierr,form='binary')
  57.     if (ierr .ne. 0) then
  58.       write (*,*)
  59.       write (*,'('' Output file "'',a,''" exists.'')') f2(1:iflen)
  60.       write (*,'('' Hit (CR) to overwrite, (^C) to cancel. '',$)')
  61.       read (*,*)
  62.       open (2,file=f2,status='old',iostat=ierr,form='binary')
  63.       if (ierr .ne. 0) call error
  64.     end if
  65.  
  66. !           initialize sixel mode in LJ250, and define colors:
  67. !         #1=red, #2=yellow, #3=green, #4=cyan, #5=blue, #6=magenta, #7=black
  68.     write (2) esc,'P9;0;4q#7;1;0;0;100#1;1;135;50;100',
  69.      +           '#2;1;170;50;100#3;1;240;50;100#4;1;315;50;100',
  70.      +           '#5;1;15;50;100#6;1;75;50;100'
  71.  
  72.     apen = .false.
  73.     nx = 0
  74.     ny = 0
  75.     lx = 0
  76.     ly = 0
  77.     lastchr = 45                ! initialize w/ LF
  78.     nrept = 1
  79.     ipen = 0
  80.     pixels = 0
  81.  
  82.     do while (.true.)                       ! read input
  83.       read (1,iostat=iend) i1               ! read function
  84.       if (iend .eq. 1) call eof
  85.  
  86.       if (i1 .eq. 1) then            ! begin plot (single byte)
  87.         continue
  88.  
  89.       else if (i1 .eq. 2) then        ! end plot (single byte)
  90.         exit
  91.  
  92.       else if (i1 .eq. 3) then        ! move (byte,word,word)
  93.         apen = .false.            ! move, pen up (byte,word,word)
  94.         lx = readx()
  95.         ly = ready()
  96.  
  97.       else if (i1 .eq. 4) then        ! draw (byte,word,word)
  98.         apen = .true.
  99.         nx = readx()        ! readx,ready do:  read I*2 word,
  100.         ny = ready()        ! correct for unsigned, normalize
  101.         ndx = iabs(nx-lx)
  102.         ndy = iabs(ny-ly)
  103.         nd = max(ndx,ndy)        ! number of steps for good resolution
  104.         if (nd .ne. 0) then
  105.           dx = (float(nx)-float(lx))/float(nd)
  106.           dy = (float(ny)-float(ly))/float(nd)
  107.           do ijk = 0, nd        ! here is where vector rasterizes...
  108.             nx1 = lx + int(float(ijk)*dx+.5)
  109.             ny1 = ly + int(float(ijk)*dy+.5)
  110.             call plot(nx1,ny1)
  111.           end do
  112.         else            ! ...unless it is so short it is a dot.
  113.           nx1 = nx
  114.           ny1 = ny
  115.           call plot(nx1,ny1)
  116.         end if
  117.         lx = nx
  118.         ly = ny
  119.  
  120.       else if (i1 .eq. 5) then        ! newpen (byte,byte)
  121.         read (1,iostat=iend) i1               ! read pen value
  122.         if (iend .eq. 1) call eof
  123.         if (ipen .ne. 0) then
  124.           write (*,'('' saving pen '',i2,'' data'')') ipen
  125.           write (f3,'(''pen'',i1,''.dat'',a1)') ipen,char(0)
  126.           open (unit=3,file=f3,status='new',iostat=ierr,
  127.      +                   form='binary',blocksize=8192)
  128.           if (ierr .ne. 0) call error
  129.           do ll = 1, 238            ! write raster map for old pen
  130.             l0 = 136*(ll-1)            ! to temporary datafile
  131.             write (3) ((pixels(l+l0,j),l=1,136),j=1,6)
  132.           end do
  133.           close (3)
  134.           pixels = 0
  135.         end if
  136.         ipen = i1                ! and start new pen map
  137.         write (*,'('' plotting vectors to pixel map, pen '',i2)') ipen
  138.  
  139.       else if (i1 .eq. 6) then        ! setspeed (byte,byte)
  140.         read (1,iostat=iend) i1
  141.         if (iend .eq. 1) call eof
  142.  
  143.       else if (i1 .eq. 7) then        ! setlinetype (byte byte)
  144.         read (1,iostat=iend) i1
  145.         if (iend .eq. 1) call eof
  146.  
  147.       else if (i1 .eq. 8) then        ! penchange (single byte)
  148.         continue
  149.  
  150.       else if (i1 .eq. 9) then        ! abort (single byte)
  151.         stop 'abort command in ADI file'
  152.  
  153.       else
  154.         write (*,*) 'unknown command in ADI file:  ',i1
  155.         stop        'abnormal termination.'
  156.       end if
  157.     end do
  158.  
  159.     if (ipen .ne. 0) then        ! don't forget to save last active pen
  160.       write (*,'('' saving pen '',i2,'' data'')') ipen
  161.       write (f3,'(''pen'',i1,''.dat'',a1)') ipen,char(0)
  162.       open (unit=3,file=f3,status='new',form='binary',blocksize=8192)
  163.       do ll = 1, 238            ! write raster map to file
  164.         l0 = 136*(ll-1)
  165.         write (3) ((pixels(l+l0,j),l=1,136),j=1,6)
  166.       end do
  167.       close (3)
  168.     end if
  169.  
  170.  
  171.     iunit = 10
  172.     npen = 0
  173.     do i = 1, 7                ! start output file
  174.       write (f3,'(''pen'',i1,''.dat'',a1)') i,char(0)
  175.       open (unit=iunit,file=f3,status='old',iostat=ierr,
  176.      +                      form='binary',blocksize=8192)
  177.       if (ierr .eq. 0) then            ! found a valid raster map,
  178.         npen = npen + 1            ! this pen is active...
  179.         unit(npen) = iunit
  180.         ppen(npen) = i
  181.         iunit = iunit + 1
  182.       end if
  183.     end do
  184.  
  185.     write (*,'('' converting pixel map to sixel string, '',i1,
  186.      +                   '' pen(s) active''/'' '')') npen
  187.     do i = 1, 238                ! 238 lines of sixels
  188.       write (*,'(''+...line '',i3,''/238'')') i
  189.       call dumpit (int1(45),nrept,lastchr)    ! send linefeed
  190.       do np = 1, npen            ! scan through this line for 
  191.         read (unit(np)) (pix(ij),ij=1,816)        ! each pen
  192.         blank = .true.
  193.         do j = 1, 816
  194.           if (pix(j) .ne. 0) then
  195.             blank = .false.
  196.             exit
  197.           end if
  198.         end do
  199.         if (blank) cycle            ! ignore pen if line blank
  200.  
  201.         call dumpit (int1(36),nrept,lastchr)    ! send CR
  202.         call dumpit (int1(35),nrept,lastchr)    ! setup new pen
  203.         call dumpit (int1(ppen(np)+48),nrept,lastchr)
  204.         call dumpit (int1(63),nrept,lastchr)    ! tab over a bit
  205.         nrept = 80
  206.         do j = 1, 135        ! 136 bytes per line
  207.           do k = 1, 8        ! 8 vertical sixels per byte
  208.             ik = 1
  209.             if (k .gt. 1) ik = 2**(k-1)
  210.             chrout = 63
  211.             if (iand(pix(    j),ik) .ne. 0) chrout = chrout + 1
  212.             if (iand(pix(136+j),ik) .ne. 0) chrout = chrout + 2
  213.             if (iand(pix(272+j),ik) .ne. 0) chrout = chrout + 4
  214.             if (iand(pix(408+j),ik) .ne. 0) chrout = chrout + 8
  215.             if (iand(pix(544+j),ik) .ne. 0) chrout = chrout + 16
  216.             if (iand(pix(680+j),ik) .ne. 0) chrout = chrout + 32
  217.             if (chrout .eq. lastchr) then
  218.               nrept = nrept + 1
  219.             else 
  220.               call dumpit (chrout,nrept,lastchr) 
  221.             end if
  222.           end do
  223.         end do
  224.       end do
  225.     end do
  226.     call dumpit (int1(0),nrept,lastchr)
  227.     write (2) esc,'/'
  228.  
  229.     do i = 1, npen            ! sixel mode now off, buffer purged
  230.       close (unit(i),status='delete')
  231.     end do
  232.     close (1)
  233.     close (2)
  234.     write (*,*) 'done'
  235.  
  236.     end
  237.  
  238.  
  239.     subroutine eof
  240.     write (*,*) '  '
  241.     write (*,*) 'Abnormal termination - unexpected end of file.'
  242.     write (*,*) '  '
  243.     stop
  244.     return
  245.     end
  246.  
  247.     subroutine error
  248.     write (*,*) '  '
  249.     write (*,*) 'Intended use:  convert an AutoCAD plotter .PLT file'
  250.     write (*,*) 'into a .COL (DEC LJ250 color printer) file.'
  251.     write (*,*) '  '
  252.     write (*,*) 'Configure AutoCAD to Generic ADI driver, ',
  253.      +                      '180 DPI, 7.922x6.039 in.'
  254.     write (*,*) '  '
  255.     write (*,*) 'Useage:  ADI2COL file'
  256.     write (*,*) '   input file extension must be .PLT'
  257.     write (*,*) '   output file extension will be .COL'
  258.     write (*,*) '  '
  259.     write (*,*) '                   Jeff Casey (last mod 10/24/90)'
  260.     stop ' '
  261.     return
  262.     end
  263.  
  264.     subroutine plot (nx,ny)
  265.     integer*1 pixels [huge] (32368,6)
  266.     common /big/ pixels
  267. !                convert coordinate to bit in pixel map
  268.     if (nx .lt. 0)    nx = 0
  269.     if (nx .gt. 1426) nx = 1426
  270.     if (ny .lt. 0)    ny = 0
  271.     if (ny .gt. 1087) ny = 1087
  272.  
  273.     n0 = 1
  274.     if (mod(ny,8) .ne. 0) n0 = 2**mod(ny,8)
  275.     n = ny/8 + (nx/6)*136
  276.     nn = mod(nx,6)
  277.     pixels(n,nn+1) = int1(ior(pixels(n,nn+1),n0))
  278.     return
  279.     end
  280.  
  281.  
  282.     subroutine dumpit (chrout,nrept,lastchr)
  283. !        write output format for char CHROUT repeated NREPT times
  284.     logical sigzer            ! flag for significant zeros
  285.     integer*1 chrout, lastchr
  286.  
  287.     if (nrept .gt. 2) then
  288.       write (2) int1(33)        ! repeat code
  289.       sigzer = .false.
  290.       if (nrept .gt. 999) then
  291.         n = nrept/1000
  292.         nrept = nrept - n*1000
  293.         write (2) int1(48+n)
  294.         sigzer = .true.
  295.       end if
  296.       if (sigzer .or. (nrept .gt. 99)) then
  297.         n = nrept/100
  298.         nrept = nrept - n*100
  299.         write (2) int1(48+n)
  300.         sigzer = .true.
  301.       end if
  302.       if (sigzer .or. (nrept .gt. 9)) then
  303.         n = nrept/10
  304.         nrept = nrept - n*10
  305.         write (2) int1(48+n)
  306.       end if
  307.       write (2) int1(48+nrept)
  308.     else if (nrept .eq. 2) then
  309.       write (2) int1(lastchr)
  310.     end if
  311.     write (2) int1(lastchr)
  312.     lastchr = chrout
  313.     nrept = 1
  314.     return
  315.     end
  316.  
  317.     integer*4 function readx ()
  318.     integer*2 i2
  319.     read (1,iostat=iend) i2
  320.     if (iend .eq. 1) call eof
  321.     readx = i2
  322.     if (readx .lt. 0) readx = readx + 64*1024
  323.     readx = int( float(readx)/4095. * 1426. + .5 )
  324.     return
  325.     end
  326.  
  327.     integer*4 function ready ()
  328.     integer*2 i2
  329.     read (1,iostat=iend) i2
  330.     if (iend .eq. 1) call eof
  331.     ready = i2
  332.     if (ready .lt. 0) ready = ready + 64*1024
  333.     ready = int( float(ready)/3071. * 1087. + .5 )
  334.     return
  335.     end
  336.